{-# LANGUAGE ViewPatterns #-}
----------------------------------------------------------------
--                                                            --
-- Module      :  LLVM.Code.Instructions.Instruction          --
-- License     :  GPL3                                        --
-- Mantainer   :  Mikhail Belyaev                             --
--                                                            --
----------------------------------------------------------------

module LLVM.Code.Instructions.Instruction where



import LLVM.Util
import LLVM.Parser.Record.Record
       (recordAsHeadlessList, getCode, RawRecord(..), recordAsList,
        RecordType(..))
import Control.Monad (liftM)
import LLVM.Code.Types (TypeTable(..))
import LLVM.Code.Values (Value(..), TypedValue(..), ValueTable(..))
import LLVM.Code.Instructions.Class
       (BuildableInstruction(..), BuildableInstruction)
import LLVM.Code.Instructions.Values (Instruction(..), resTypeOf)
import LLVM.Code.Instructions.Aggregate
import LLVM.Code.Instructions.Binary
import LLVM.Code.Instructions.Branch
import LLVM.Code.Instructions.Cast
import LLVM.Code.Instructions.Call
import LLVM.Code.Instructions.Conditional
import LLVM.Code.Instructions.Memory
import LLVM.Code.Values.Kinds (InstructionValue(..))


--     FUNC_CODE_DECLAREBLOCKS    =  1, // DECLAREBLOCKS: [n]
--
--    !FUNC_CODE_INST_BINOP       =  2, // BINOP:      [opcode, ty, opval, opval]
--    !FUNC_CODE_INST_CAST        =  3, // CAST:       [opcode, ty, opty, opval]
--    !FUNC_CODE_INST_GEP         =  4, // GEP:        [n x operands]
--    !FUNC_CODE_INST_SELECT      =  5, // SELECT:     [ty, opval, opval, opval]
--    !FUNC_CODE_INST_EXTRACTELT  =  6, // EXTRACTELT: [opty, opval, opval]
--    !FUNC_CODE_INST_INSERTELT   =  7, // INSERTELT:  [ty, opval, opval, opval]
--    !FUNC_CODE_INST_SHUFFLEVEC  =  8, // SHUFFLEVEC: [ty, opval, opval, opval]
--    !FUNC_CODE_INST_CMP         =  9, // CMP:        [opty, opval, opval, pred]
--
--    !FUNC_CODE_INST_RET         = 10, // RET:        [opty,opval<both optional>]
--    !FUNC_CODE_INST_BR          = 11, // BR:         [bb#, bb#, cond] or [bb#]
--    !FUNC_CODE_INST_SWITCH      = 12, // SWITCH:     [opty, op0, op1, ...]
--    !FUNC_CODE_INST_INVOKE      = 13, // INVOKE:     [attr, fnty, op0,op1, ...]
--    !FUNC_CODE_INST_UNWIND      = 14, // UNWIND
--     FUNC_CODE_INST_UNREACHABLE = 15, // UNREACHABLE
--
--    !FUNC_CODE_INST_PHI         = 16, // PHI:        [ty, val0,bb0, ...]
--    !FUNC_CODE_INST_MALLOC      = 17, // MALLOC:     [instty, op, align]
--    !FUNC_CODE_INST_FREE        = 18, // FREE:       [opty, op]
--    !FUNC_CODE_INST_ALLOCA      = 19, // ALLOCA:     [instty, op, align]
--    !FUNC_CODE_INST_LOAD        = 20, // LOAD:       [opty, op, align, vol]
--     // FIXME: Remove STORE in favor of STORE2 in LLVM 3.0
--    !FUNC_CODE_INST_STORE       = 21, // STORE:      [valty,val,ptr, align, vol]
--     // FIXME: Remove CALL in favor of CALL2 in LLVM 3.0
--    !FUNC_CODE_INST_CALL        = 22, // CALL with potentially invalid metadata
--     FUNC_CODE_INST_VAARG       = 23, // VAARG:      [valistty, valist, instty]
--     // This store code encodes the pointer type, rather than the value type
--     // this is so information only available in the pointer type (e.g. address
--     // spaces) is retained.
--    !FUNC_CODE_INST_STORE2      = 24, // STORE:      [ptrty,ptr,val, align, vol]
--     // FIXME: Remove GETRESULT in favor of EXTRACTVAL in LLVM 3.0
--    !FUNC_CODE_INST_GETRESULT   = 25, // GETRESULT:  [ty, opval, n]
--    !FUNC_CODE_INST_EXTRACTVAL  = 26, // EXTRACTVAL: [{vtpair},v]
--    !FUNC_CODE_INST_INSERTVAL   = 27, // INSERTVAL:  [n x operands]
--     // fcmp/icmp returning Int1TY or vector of Int1Ty. Same as CMP, exists to
--     // support legacy vicmp/vfcmp instructions.
--    !FUNC_CODE_INST_CMP2        = 28, // CMP2:       [opty, opval, opval, pred]
--     // new select on i1 or [N x i1]
--    !FUNC_CODE_INST_VSELECT     = 29, // VSELECT:    [ty,opval,opval,predty,pred]
--    !FUNC_CODE_INST_INBOUNDS_GEP= 30, // INBOUNDS_GEP: [n x operands]
--    !FUNC_CODE_INST_INDIRECTBR  = 31, // INDIRECTBR: [opty, op0, op1, ...]
--
--     // FIXME: Remove DEBUG_LOC in favor of DEBUG_LOC2 in LLVM 3.0
--     FUNC_CODE_DEBUG_LOC        = 32, // DEBUG_LOC with potentially invalid metadata
--     FUNC_CODE_DEBUG_LOC_AGAIN  = 33, // DEBUG_LOC_AGAIN
--
--    !FUNC_CODE_INST_CALL2       = 34, // CALL2:      [attr, fnty, fnid, args...]
--
--     FUNC_CODE_DEBUG_LOC2       = 35  // DEBUG_LOC2: [Line,Col,ScopeVal, IAVal]




isTerminating :: Instruction -> Bool
isTerminating (IRet _ ) = True
isTerminating (IBranch _) = True
isTerminating (ISwitch _) = True
isTerminating (IIndirBr _) = True
isTerminating (IInvoke _) = True
isTerminating (IUnwind _) = True
isTerminating (IUnreachable _) = True
isTerminating _ = False

formWith :: (BuildableInstruction spec) => (spec -> a) -> RawRecord -> TypeTable -> ValueTable -> Maybe a
formWith former rr tt vt = liftM former $ buildInstruction rr tt vt

formInstructionBodyFromCode :: Integer -> RawRecord -> TypeTable -> ValueTable -> Maybe Instruction
formInstructionBodyFromCode 1  = deepconst (Nothing::Maybe Instruction) -- BB declaration
formInstructionBodyFromCode 2  = formWith IBinary
formInstructionBodyFromCode 3  = formWith ICast
formInstructionBodyFromCode 4  = formWith IGEP
formInstructionBodyFromCode 5  = formWith ISelect
formInstructionBodyFromCode 6  = formWith IExtractEl
formInstructionBodyFromCode 7  = formWith IInsertEl
formInstructionBodyFromCode 8  = formWith IShuffleVec
formInstructionBodyFromCode 9  = formWith ICmp
formInstructionBodyFromCode 10 = formWith IRet
formInstructionBodyFromCode 11 = formWith IBranch
formInstructionBodyFromCode 12 = formWith ISwitch
formInstructionBodyFromCode 13 = formWith IInvoke
formInstructionBodyFromCode 14 = formWith IUnwind
formInstructionBodyFromCode 15 = formWith IUnreachable
formInstructionBodyFromCode 16 = formWith IPhi
formInstructionBodyFromCode 17 = formWith IMalloc
formInstructionBodyFromCode 18 = formWith IFree
formInstructionBodyFromCode 19 = formWith IAlloca
formInstructionBodyFromCode 20 = formWith ILoad
formInstructionBodyFromCode 21 = formWith IStore
formInstructionBodyFromCode 22 = formWith ICall
formInstructionBodyFromCode 24 = formWith IStore
formInstructionBodyFromCode 25 = formWith IExtractV
formInstructionBodyFromCode 26 = formWith IExtractV
formInstructionBodyFromCode 27 = formWith IInsertV
formInstructionBodyFromCode 28 = formWith ICmp
formInstructionBodyFromCode 29 = formWith ISelect
formInstructionBodyFromCode 30 = formWith IGEP
formInstructionBodyFromCode 31 = formWith IIndirBr
formInstructionBodyFromCode 32 = deepconst (Nothing::Maybe Instruction) -- DEBUGLOC
formInstructionBodyFromCode 33 = deepconst (Nothing::Maybe Instruction) -- DEBUGLOCAGAIN
formInstructionBodyFromCode 34 = formWith ICall
formInstructionBodyFromCode 35 = deepconst (Nothing::Maybe Instruction) -- DEBUGLOC2
formInstructionBodyFromCode _  = deepconst (Nothing::Maybe Instruction) -- should not happen, but...

fOR :: (a -> Bool) -> (a -> Bool) -> a -> Bool
fOR p1 p2 a = p1 a || p2 a
fAND :: (a -> Bool) -> (a -> Bool) -> a -> Bool
fAND p1 p2 a = p1 a && p2 a
fNOT :: (a -> Bool) -> (a -> Bool)
fNOT p a = not$ p a

isInstruction :: RawRecord -> Bool
isInstruction (getCode -> Just  ( ((>1) `fAND` (<32)) `fOR` (==34) -> True )) = True
isInstruction _ = False

instance BuildableInstruction Instruction where
    buildInstruction rr@(getCode -> Just cd) tt vt
                     = formInstructionBodyFromCode cd rr tt vt
    buildInstruction _ _ _ = Nothing

instance TypedValue Instruction where
    toValue i = InstructionV $ InstructionValue i Nothing
    getType val tt = resTypeOf val tt

--fromRawRecs :: [RawRecord] -> [Instruction]
--fromRawRecs (i:d:tl)   = case  (fromRawRecord $ idebug i,fromRawRecord d) of
--                              (Just instr, Just dl) -> Instruction{
--                                                           instBody = instr,
--                                                           instLoc = Just dl
--                                                      } : fromRawRecs tl
--                              (Just instr, Nothing) -> Instruction{
--                                                           instBody = instr,
--                                                           instLoc = Nothing
--                                                      } : fromRawRecs (d:tl)
--                              (Nothing, _) -> fromRawRecs (d:tl)
--fromRawRecs (i:[]) = case idebug (fromRawRecord i) of
--                          (Just instr) -> [ Instruction {instBody = instr, instLoc = Nothing} ]
--                          Nothing -> []
--fromRawRecs [] = []

